home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / scoops.scm < prev    next >
Encoding:
Text File  |  1993-07-16  |  41.8 KB  |  1,251 lines
  1. ;;;
  2. ;;;    Copyright (c) 1986 Texas Instruments Incorporated
  3. ;;;
  4. ;;;    Permission to copy this software, to redistribute it, and
  5. ;;;     to use it for any purpose is granted, subject to the
  6. ;;;     following restrictions and understandings.
  7. ;;;
  8. ;;;    1. Any copy made of this software must include this copyright
  9. ;;;    notice in full.
  10. ;;;
  11. ;;;    2.  All materials developed as a consequence of the use of
  12. ;;;    this software shall duly acknowledge such use, in accordance
  13. ;;;    with the usual standards of acknowledging credit in academic
  14. ;;;    research.
  15. ;;;
  16. ;;;    3. TI has made no warranty or representation that the
  17. ;;;    operation of this software will be error-free, and TI is
  18. ;;;    under no obligation to provide any services, by way of
  19. ;;;    maintenance, update, or otherwise.
  20. ;;;
  21. ;;;    4.  In conjunction with products arising from the use
  22. ;;;    of this material, there shall be no use of the name of
  23. ;;;     Texas Instruments (except for the above copyright credit)
  24. ;;;    nor of any adaptation thereof in any advertising, promotional,
  25. ;;;     or sales literature without prior written consent from TI in
  26. ;;;     each case.
  27. ;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. ;;; --- Modified SCOOPS taken from archive at altdorf.ai.mit.edu to make
  31. ;;;     it work with MIT Scheme 7.1, 6 May 1991 - Peter Ross, Dept of AI,
  32. ;;;     University of Edinburgh, Scotland; peter@aipna.ed.ac.uk
  33. ;;;
  34. ;;; Several small mods had to be made to Steve Sherin's version for
  35. ;;; Scheme 6.2, as patched and found in the archive at altdorf. Summary:
  36. ;;; - it turned out that the class compilation had NEVER (!?) worked
  37. ;;;   correctly; the function %sc-method-thrust evaluated each method
  38. ;;;   in the environment returned by (%sc-method-env class), by iterating
  39. ;;;   over method info in (%sc-method-values class). That contained only
  40. ;;;   those methods which had been explicitly attached to the class, not
  41. ;;;   any which where inherited from mixins too. The only information
  42. ;;;   about mixin methods, before class compilation time, resides in
  43. ;;;   what (%sc-method-struct class) returns. So %sc-method-thrust has
  44. ;;;   been changed to make it work correctly.
  45. ;;; - the macros were set up by syntax-table-define, so took effect
  46. ;;;   at load time; even those which were needed at system compile time.
  47. ;;;   The MIT Scheme Support Team contributed the notion of
  48. ;;;   define-macro-both, which is defined both by syntax-table-define
  49. ;;;   and define-macro and which defines a macro both ways. Tedious
  50. ;;;   but probably wiser as a defence for anybody who might want to
  51. ;;;   compile SCOOPS together with their own stuff some day.
  52. ;;; - removed a couple of the silly macros
  53. ;;; - cleaned up usage of #t/#!true etc. Note that #f is still
  54. ;;;   the same as the empty list in MIT Scheme 7.1, despite what
  55. ;;;   the Scheme standard says, and #f prints as () by default.
  56. ;;; - the original had this odd macro:
  57. ;;;      (syntax-table-define user-initial-syntax-table 'REC
  58. ;;;        (macro (name lambda-exp)
  59. ;;;           `(begin (define ,name ,lambda-exp) ,name)))
  60. ;;;   which is, alas, not legal Scheme (define at start of a begin
  61. ;;;   but a begin is not a lambda body). Interestingly, SF passed
  62. ;;;   this but Liar barfed on it. However, the macro seems to have
  63. ;;;   existed because of the stylistic sense of somebody somewhere
  64. ;;;   who was brought up on CL-type ITERATE macros (not Steve Sherin,
  65. ;;;   since REC exists as such in PC-Scheme). Edited it out.
  66. ;;;
  67. ;;; So now the .scm, .bin and .com versions should all work correctly.
  68. ;;; But I had very few examples of SCOOPS use on which to test them,
  69. ;;; so don't curse me if you find another bug. Tell me instead...
  70. ;;;
  71. ;;; See scoops.txt for some user documentation.
  72. ;;;
  73. ;;; Many thanks to the MIT Scheme Support Team, whose responsiveness
  74. ;;; to my queries was excellent.
  75.  
  76.  
  77.  
  78.  
  79. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80. ;;;                                                                 ;;;
  81. ;;;                     S c o o p s                                 ;;;
  82. ;;;                                                                 ;;;
  83. ;;;               File updated : 5/23/86                            ;;;
  84. ;;;                                                                 ;;;
  85. ;;;                   File : class.scm                              ;;;
  86. ;;;                                                                 ;;;
  87. ;;;                 Amitabh Srivastava                              ;;;
  88. ;;;                                                                 ;;;
  89. ;;;         This file handles class creation.                       ;;;
  90. ;;;                                                                 ;;;
  91. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92.  
  93. (declare (usual-integrations))
  94.  
  95. (define ALL-CLASSVARS)
  96. (define ALL-INSTVARS)
  97. (define ALL-METHODS)
  98. (define CLASS-COMPILED?)
  99. (define CLASSVARS)
  100. (define DESCRIBE)
  101. (define INSTVARS)
  102. (define METHODS)
  103. (define MIXINS)
  104.  
  105. ;;; These definitions are to bring scoops up to date with MIT Scheme 7.1
  106.  
  107. (define parser-package (->environment (find-package '(runtime parser))))
  108. (define unparser-package (->environment (find-package '(runtime unparser))))
  109. (define environment-package (->environment
  110.                  (find-package '(runtime environment))))
  111. (define (writeln . objects)
  112.   (newline)
  113.   (for-each display objects))
  114.  
  115. ;;; Following hack courtesy of MIT Scheme support team:
  116. ;;;   define-macro is for the compile-time stuff,
  117. ;;;   syntax-table-define stuff does not tacke effect
  118. ;;;     until load time.
  119. ;;; So to get a macro to take effect at compile time and
  120. ;;; also make it available at load time, use this:
  121.  
  122. (define-macro (define-macro-both params  . body)
  123.   (let ((name (car params))
  124.         (params* (cdr params)))
  125.     `(begin
  126.        (define-macro ,params ,@body)
  127.        (syntax-table-define user-initial-syntax-table ',name
  128.          (macro ,params* ,@body)))))
  129.  
  130. (syntax-table-define system-global-syntax-table 'define-macro-both
  131.   (macro (pattern . body)
  132.     `(begin
  133.        (define-macro ,pattern ,@body)
  134.        (syntax-table-define user-initial-syntax-table ',(car pattern)
  135.          (macro ,(cdr pattern)
  136.            ,@body)))))
  137.  
  138. ;;;
  139.  
  140. (define %%class-tag (intern "#!CLASS"))
  141.  
  142. (set! (access named-objects parser-package) 
  143.       (cons (cons 'CLASS %%class-tag) (access named-objects parser-package)))
  144.  
  145.  
  146. ((access add-unparser-special-object! unparser-package) %%class-tag
  147.  (lambda (class)
  148.    ((access unparse-with-brackets unparser-package)
  149.     (lambda ()
  150.       (write-string "SCOOPS Class ")
  151.       (write (hash class))))))
  152.  
  153.  
  154. (define %sc-make-class
  155.   (lambda (name cv allivs mixins method-values)
  156.     (let ((method-structure
  157.                   (map (lambda (a) (list (car a) (cons name name)))
  158.                           method-values))
  159.           (class (make-vector 15)))
  160.        (vector-set! class 0 %%class-tag)
  161.        (vector-set! class 1 name)
  162.        (vector-set! class 2 cv)
  163.        (vector-set! class 3 cv)
  164.        (vector-set! class 4 allivs)
  165.        (vector-set! class 5 mixins)
  166.        (vector-set! class 6 (%uncompiled-make-instance class))
  167.        (vector-set! class 9 method-structure)
  168.        (vector-set! class 13 method-values)
  169.        (vector-set! class 14 allivs)
  170.        (2d-put! name '%class class)
  171.        class)))
  172.  
  173. (define %scoops-chk-class
  174.   (lambda (class)
  175.     (and (not (and (vector? class)
  176.                    (> (vector-length class) 0)
  177.                    (equal? %%class-tag (vector-ref class 0))))
  178.          (error-handler class 6 #t))))
  179.  
  180.  
  181. ;;; %sc-name
  182. (define-integrable (%sc-name class)
  183.     (vector-ref class 1))
  184.  
  185. ;;; %sc-cv
  186. (define-integrable (%sc-cv class)
  187.     (vector-ref class 2))
  188.  
  189. ;;; %sc-allcvs
  190. (define-integrable (%sc-allcvs class)
  191.     (vector-ref class 3))
  192.  
  193. ;;; %sc-allivs
  194. (define-integrable (%sc-allivs class)
  195.     (vector-ref class 4))
  196.  
  197. ;;; %sc-mixins
  198. (define-integrable (%sc-mixins class)
  199.     (vector-ref class 5))
  200.  
  201. ;;; %sc-inst-template
  202. (define-integrable (%sc-inst-template class)
  203.     (vector-ref class 6))
  204.  
  205. ;;; %sc-method-env
  206. (define-integrable (%sc-method-env class)
  207.     (vector-ref class 7))
  208.  
  209. ;;; %sc-class-env
  210. (define-integrable (%sc-class-env class)
  211.     (vector-ref class 8))
  212.  
  213.  
  214. ;;; %sc-method-structure
  215. (define-integrable (%sc-method-structure class)
  216.     (vector-ref class 9))
  217.  
  218. ;;; %sc-subclasses
  219. (define-integrable (%sc-subclasses class)
  220.     (vector-ref class 10))
  221.  
  222. ;;; %sc-class-compiled
  223. (define-integrable (%sc-class-compiled class)
  224.     (vector-ref class 11))
  225.  
  226. ;;; %sc-class-inherited
  227. (define-integrable (%sc-class-inherited class)
  228.     (vector-ref class 12))
  229.  
  230. ;;; %sc-method-values
  231. (define-integrable (%sc-method-values class)
  232.     (vector-ref class 13))
  233.  
  234. (define-integrable (%sc-iv class)
  235.     (vector-ref class 14))
  236.  
  237. ;;; %sc-set-name
  238. (define-integrable (%sc-set-name class val)
  239.     (vector-set! class 1 val))
  240.  
  241. ;;; %sc-set-cv
  242. (define-integrable (%sc-set-cv class val)
  243.     (vector-set! class 2 val))
  244.  
  245.  
  246. ;;; %sc-set-allcvs
  247. (define-integrable (%sc-set-allcvs class val)
  248.     (vector-set! class 3 val))
  249.  
  250. ;;; %sc-set-allivs
  251. (define-integrable (%sc-set-allivs class val)
  252.     (vector-set! class 4 val))
  253.  
  254. ;;; %sc-set-mixins
  255. (define-integrable (%sc-set-mixins class val)
  256.     (vector-set! class 5 val))
  257.  
  258. ;;; %sc-set-inst-template
  259. (define-integrable (%sc-set-inst-template class val)
  260.     (vector-set! class 6 val))
  261.  
  262. ;;; %sc-set-method-env
  263. (define-integrable (%sc-set-method-env class val)
  264.     (vector-set! class 7 val))
  265.  
  266. ;;; %sc-set-class-env
  267. (define-integrable (%sc-set-class-env class val)
  268.     (vector-set! class 8 val))
  269.  
  270. ;;; %sc-set-method-structure
  271. (define-integrable (%sc-set-method-structure class val)
  272.     (vector-set! class 9 val))
  273.  
  274. ;;; %sc-set-subclasses
  275. (define-integrable (%sc-set-subclasses class val)
  276.     (vector-set! class 10 val))
  277.  
  278.  
  279. ;;; %sc-set-class-compiled
  280. (define-integrable (%sc-set-class-compiled class val)
  281.     (vector-set! class 11 val))
  282.  
  283. ;;; %sc-set-class-inherited
  284. (define-integrable (%sc-set-class-inherited class val)
  285.     (vector-set! class 12 val))
  286.  
  287. ;;; %sc-set-method-values
  288. (define-integrable (%sc-set-method-values class val)
  289.     (vector-set! class 13 val))
  290.  
  291. ;;; %sc-set-iv
  292. (define-integrable (%sc-set-iv class val)
  293.     (vector-set! class 14 val))
  294.  
  295.  
  296. ;;;
  297. (define %sc-name->class
  298.   (lambda (name)
  299.     (cond ((2d-get name '%class) => (lambda (a) a))
  300.           (else (error-handler name 2 #t)))))
  301.  
  302. ;;; %sc-get-meth-value
  303. (define-integrable (%sc-get-meth-value meth-name class)
  304.     (cdr (assq meth-name (%sc-method-values class))))
  305.  
  306. ;;; %sc-get-cv-value
  307. (define-integrable (%sc-get-cv-value var class)
  308.     (cadr (assq var (%sc-cv class))))
  309.  
  310. ;;; %sc-concat
  311. (define-integrable (%sc-concat str sym)
  312.     (intern (string-append str (symbol->string sym))))
  313.  
  314.  
  315. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  316. ;;;                                                                 ;;;
  317. ;;;                     S c o o p s                                 ;;;
  318. ;;;                                                                 ;;;
  319. ;;;                                                                 ;;;
  320. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  321. ;;;        by Steve Sherin--U of P                    ;;;
  322. ;;;                   File : methods.scm                            ;;;
  323. ;;;                                                                 ;;;
  324. ;;;                 Amitabh Srivastava                              ;;;
  325. ;;;                                                                 ;;;
  326. ;;;    This file handles the addition/redefinition of methods.      ;;;
  327. ;;;                                                                 ;;;
  328. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  329.  
  330.  
  331. ;;; is class1 before class2 in class ?
  332. ;;; class1  is not equal to class2
  333.  
  334. (define %before
  335.   (lambda (class1 class2 class)
  336.     (or (eq? class1 class)
  337.         (memq class2 (memq class1 (%sc-mixins (%sc-name->class class)))))))
  338.  
  339. ;;; DEFINE-METHOD
  340. (syntax-table-define user-initial-syntax-table 'define-method
  341.   (macro e
  342.     (let ((class-name (caar e))
  343.           (method-name (cadar e))
  344.           (formal-list (cadr e))
  345.           (body (cddr e)))
  346.       `(%sc-class-add-method
  347.     ',class-name
  348.     ',method-name
  349.     ',class-name
  350.     ',class-name
  351.     (append (list 'lambda ',formal-list) ',body)
  352.     (lambda (env quoted-val)
  353.       (let* ((method-name ',method-name)
  354.          (temp `(in-package ,env 
  355.               (define ,method-name
  356.                 ,quoted-val))))
  357.         (eval temp (the-environment)))
  358.       )))))
  359. ;;;
  360.  
  361. (define %sc-class-add-method
  362.   (lambda (class-name
  363.        method-name
  364.        method-class
  365.        mixin-class
  366.        method
  367.        assigner)
  368.     (let ((class (%sc-name->class class-name)))
  369.       (begin
  370.     (let ((temp (assq method-name (%sc-method-values class))))
  371.       (if temp
  372.           (set-cdr! temp method)
  373.           (%sc-set-method-values 
  374.            class
  375.            (cons (cons method-name method) (%sc-method-values class))))))
  376.       (%compiled-add-method class-name method-name method-class mixin-class
  377.                 method assigner))))
  378. ;;;
  379.  
  380. (define %inform-subclasses
  381.   (lambda (class-name method-name method-class mixin-class method assigner)
  382.     (define loop
  383.        (lambda (class-name method-name method-class mixin-class
  384.                                        method assigner subclass)
  385.          (if subclass
  386.              (begin
  387.                 (%compiled-add-method
  388.                   (car subclass) method-name method-class class-name
  389.                   method assigner)
  390.                 (loop class-name method-name method-class mixin-class
  391.                       method assigner
  392.                       (cdr subclass))))))
  393.      (loop class-name method-name method-class mixin-class method assigner
  394.      (%sc-subclasses (%sc-name->class class-name)))))
  395. ;;;
  396.  
  397. (define %compiled-add-method
  398.   (lambda (class-name
  399.        method-name
  400.        method-class
  401.        mixin-class
  402.        method
  403.        assigner)
  404.     (letrec
  405.       ((class (%sc-name->class class-name))
  406.  
  407.        (insert-entry
  408.          (lambda (previous current)
  409.            (cond ((null? current)
  410.                   (set-cdr! previous
  411.                      (cons (cons method-class mixin-class) '())))
  412.                  ((eq? mixin-class (cdar current))
  413.                   (set-car! (car current) method-class))
  414.                  ((%before mixin-class (cdar current)
  415.                            class-name)
  416.                   (set-cdr! previous
  417.                      (cons (cons method-class mixin-class) current)))
  418.                  (else '()))))
  419.  
  420.  
  421.        (loop-insert
  422.          (lambda (previous current)
  423.            (if (not (insert-entry previous current))
  424.                (loop-insert (current) (cdr current)))))
  425.  
  426.        (insert
  427.          (lambda (entry)
  428.            (if (insert-entry entry (cdr entry))  ;;; insert at head
  429.                (add-to-environment)
  430.                (loop-insert (cdr entry) (cddr entry)))))
  431.  
  432.        (add-to-environment
  433.          (lambda ()
  434.      (begin
  435.            (if (%sc-class-compiled class)
  436.                 (assigner (%sc-method-env class) method))
  437.            (if (%sc-subclasses class)
  438.                (%inform-subclasses class-name method-name method-class
  439.                                   mixin-class method assigner)))))
  440.  
  441.        (add-entry
  442.          (lambda ()
  443.      (begin
  444.            (%sc-set-method-structure class
  445.              (cons (list method-name (cons method-class mixin-class))
  446.                    (%sc-method-structure class)))
  447.            (add-to-environment))))
  448.       )
  449.  
  450.       (let ((method-entry (assq method-name (%sc-method-structure class))))
  451.         (if method-entry
  452.             (insert method-entry)
  453.             (add-entry))
  454.         method-name))))
  455. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  456. ;;;                                                                 ;;;
  457. ;;;                     S c o o p s                                 ;;;
  458. ;;;                                                                 ;;;
  459. ;;;                                                                 ;;;
  460. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  461. ;;;        by Steve Sherin--U of P                    ;;;
  462. ;;;                   File : meth2.scm                              ;;;
  463. ;;;                                                                 ;;;
  464. ;;;                 Amitabh Srivastava                              ;;;
  465. ;;;                                                                 ;;;
  466. ;;;    This file handles the deletion of a method from a class.     ;;;
  467. ;;;                                                                 ;;;
  468. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  469.  
  470. ;;; DELETE-METHOD 
  471. (syntax-table-define user-initial-syntax-table 'delete-method
  472.   (macro e
  473.     (let ((class-name (caar e))
  474.           (method-name (cadar e)))
  475.       `(%sc-class-del-method
  476.     ',class-name
  477.     ',method-name
  478.     ',class-name
  479.     ',class-name
  480.     (LAMBDA (ENV VAL)
  481.       (SET! (ACCESS ,method-name ENV) VAL))
  482.     #f))))
  483. ;;;
  484.  
  485. (define %deleted-method
  486.   (lambda (name)
  487.     (lambda args
  488.       (error-handler name 3 #t))))
  489. ;;;
  490.  
  491. (define %sc-class-del-method
  492.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  493.     (let ((class (%sc-name->class class-name)))
  494.       (let ((temp (assq method-name (%sc-method-values class))))
  495.     (if temp
  496.      (begin
  497.           (%sc-set-method-values class
  498.                (delq! temp (%sc-method-values class)))
  499.           (%compiled-del-method class-name method-name method-class mixin-class
  500.                                assigner del-value))
  501.  
  502.     (error-handler method-name 4 #t))))))
  503. ;;;
  504.  
  505. (define %inform-del-subclasses
  506.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  507.     (define loop
  508.        (lambda (class-name method-name method-class mixin-class assigner
  509.                 del-value subclass)
  510.          (if subclass
  511.              (begin
  512.                 (%compiled-del-method (car subclass) method-name
  513.                           method-class class-name assigner del-value)
  514.                 (loop class-name method-name method-class mixin-class assigner
  515.                       del-value (cdr subclass))))))
  516.      (loop class-name method-name method-class mixin-class assigner del-value
  517.      (%sc-subclasses (%sc-name->class class-name)))))
  518. ;;;
  519.  
  520. (define %compiled-del-method
  521.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  522.     (let ((class (%sc-name->class class-name)))
  523.       (letrec
  524.         ((delete-entry
  525.            (lambda (previous current)
  526.              (cond ((eq? mixin-class (cdar current))
  527.                     (set-cdr! previous (cdr current)) #t)
  528.                    (else #f))))
  529.  
  530.          (loop-delete
  531.            (lambda (previous current)
  532.              (cond ((or (null? current)
  533.                         (%before mixin-class (cdar previous)
  534.                                  class-name))
  535.                     (error-handler method-name 4 #t))
  536.                    ((delete-entry previous current) #t)
  537.                    (else (loop-delete current (cdr current))))))
  538.  
  539.          (delete
  540.            (lambda (entry)
  541.              (if (delete-entry entry (cdr entry))  ;;; delete at head
  542.                  (modify-environment entry)
  543.                  (loop-delete (cdr entry) (cddr entry)))))
  544.  
  545.        (modify-environment
  546.          (lambda (entry)
  547.        (cond ((null? (cdr entry))
  548.           (%sc-set-method-structure class
  549.             (delq! (assq method-name (%sc-method-structure class))
  550.                (%sc-method-structure class)))
  551.                   (if (%sc-class-compiled class)
  552.                       (assigner (%sc-method-env class)
  553.                                 (or del-value
  554.                                     (set! del-value
  555.                                           (%deleted-method method-name)))))
  556.           (if (%sc-subclasses class)
  557.               (%inform-del-subclasses class-name method-name
  558.                    method-class mixin-class assigner del-value)))
  559.          (else
  560.           (let ((meth-value
  561.              (%sc-get-meth-value method-name
  562.                          (%sc-name->class (caadr entry)))))
  563.             (if (%sc-class-compiled class)
  564.             (assigner (%sc-method-env class) meth-value))
  565.             (if (%sc-subclasses class)
  566.             (%inform-subclasses class-name
  567.                         method-name
  568.                         method-class
  569.                         mixin-class
  570.                         meth-value assigner)))))))
  571.       )
  572.  
  573.       (let ((method-entry (assq method-name (%sc-method-structure class))))
  574.         (if method-entry
  575.             (delete method-entry)
  576.             (error-handler method-name 4 #t))
  577.         method-name)))))
  578. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  579. ;;;                                                                 ;;;
  580. ;;;                     S c o o p s                                 ;;;
  581. ;;;                                                                 ;;;
  582. ;;;                                                                 ;;;
  583. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  584. ;;;        by Steve Sherin--U of P                    ;;;
  585. ;;;                   File : instance.scm                           ;;;
  586. ;;;                                                                 ;;;
  587. ;;;                 Amitabh Srivastava                              ;;;
  588. ;;;                                                                 ;;;
  589. ;;;    This file contains compiling and making of an instance.      ;;;
  590. ;;;                                                                 ;;;
  591. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  592.  
  593. ;;; COMPILE-CLASS
  594. (syntax-table-define user-initial-syntax-table 'compile-class
  595.   (macro e
  596.     `(let* ((class ,(car e))
  597.         (name (%sc-name class)))
  598.        (if (%sc-class-compiled class)
  599.        name
  600.        (begin
  601.          (%inherit-method-vars class)
  602.          (eval (%make-template name class) (the-environment)))))))
  603. ;;;
  604.  
  605. (define (%sc-compile-class class)
  606.   (begin
  607.     (%inherit-method-vars class)
  608.     (eval (%make-template (%sc-name class) class)
  609.         user-initial-environment)))
  610.  
  611. ;;; MAKE-INSTANCE
  612. (syntax-table-define user-initial-syntax-table 'make-instance
  613.   (macro e
  614.     (cons (list '%sc-inst-template (car e)) (cdr e))))
  615. ;;;
  616.  
  617. (define %uncompiled-make-instance
  618.   (lambda (class)
  619.     (lambda init-msg
  620.       (%sc-compile-class class)
  621.       (apply (%sc-inst-template class) init-msg))))
  622. ;;;
  623.  
  624. (define %make-template
  625.   (lambda (name class)
  626.     `(begin
  627. ;;; do some work to make compile-file work
  628.        (%sc-set-allcvs ,name ',(%sc-allcvs class))
  629.        (%sc-set-allivs ,name ',(%sc-allivs class))
  630.        (%sc-set-method-structure ,name
  631.             ',(%sc-method-structure class))
  632. ;;; prepare make-instance template
  633.        (%sc-set-inst-template ,name
  634.           ,(%make-inst-template (%sc-allcvs class)
  635.                                (%sc-allivs class)
  636.                                (%sc-method-structure class)
  637.                                name class))
  638.        (%sc-method-thrust ,name)
  639.        (%sc-set-class-compiled ,name #t)
  640.        (%sc-set-class-inherited ,name #t)
  641.        (%sign-on ',name ,name)
  642.        ',name)))
  643. ;;;
  644.  
  645. (define %make-inst-template
  646.   (lambda (cvs ivs method-structure name class)
  647.     (let ((methods '((%*methods*% '-)))
  648.           (classvar (append cvs '((%*classvars*% '-))))
  649.           (instvar  (append ivs '((%*instvars*% '-)))))
  650. ;;; dummy variables are added to methods, cvs, and ivs to prevent the
  651. ;;; compiler from folding them away.
  652.          `(let ,classvar
  653.            (%sc-set-class-env ,name (the-environment))
  654.             (let ,methods
  655.               (%sc-set-method-env ,name (the-environment))
  656.           (let ((%sc-class ,name))
  657.               (lambda %sc-init-vals
  658.                 (let ,instvar
  659.                   (the-environment)))))))))
  660.  
  661.  
  662.  
  663. ;;; %sc-method-thrust evaluates each method in the method-environment
  664. ;;; for the class, enabling methods to grab free variables from the
  665. ;;; class-environment without a special code-replacement call.
  666.  
  667. (define (%sc-method-thrust class)
  668.   (define (iter binding-pair)
  669.     (let* ((method-name (car binding-pair))
  670.        (quoted-val 
  671.          (cdr (assq method-name 
  672.                     (%sc-method-values (%sc-name->class 
  673.                                           (caadr binding-pair))))))
  674.        (temp `(in-package (%sc-method-env class)
  675.             (define ,method-name ,quoted-val))))
  676.       (eval temp (the-environment))))
  677. (map iter (%sc-method-structure class)))
  678.  
  679.  
  680.  
  681. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  682. ;;;                                                                 ;;;
  683. ;;;                     S c o o p s                                 ;;;
  684. ;;;                                                                 ;;;
  685. ;;;                                                                 ;;;
  686. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  687. ;;;        by Steve Sherin--U of P                    ;;;
  688. ;;;                   File : inht.scm                               ;;;
  689. ;;;                                                                 ;;;
  690. ;;;                 Amitabh Srivastava                              ;;;
  691. ;;;                                                                 ;;;
  692. ;;;    This file contains routines to handle inheritance.           ;;;
  693. ;;;                                                                 ;;;
  694. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  695.  
  696. ;;;
  697.  
  698. (define %inherit-method-vars
  699.   (lambda (class)
  700.     (or (%sc-class-inherited class)
  701.     (%inherit-from-mixins
  702.      (%sc-allcvs class)
  703.      (%sc-allivs class)
  704.      (%sc-method-structure class)
  705.      (%sc-mixins class)
  706.      class
  707.      (lambda (class cvs ivs methods)
  708.        (%sc-set-allcvs class cvs)
  709.        (%sc-set-allivs class ivs)
  710.        (%sc-set-method-structure class methods)
  711.            (%sc-set-class-inherited class #t)
  712.            (%sign-on (%sc-name class) class)
  713.        class)))))
  714. ;;;
  715.  
  716. (define %sign-on
  717.   (lambda (name class)
  718.     (map
  719.       (lambda (mixin)
  720.         (let* ((mixin-class (%sc-name->class mixin))
  721.                (subc (%sc-subclasses mixin-class)))
  722.           (if (not (%sc-class-inherited mixin-class))
  723.               (%inherit-method-vars mixin-class))
  724.           (or (memq name subc)
  725.               (%sc-set-subclasses mixin-class (cons name subc)))))
  726.       (%sc-mixins class))))
  727. ;;;
  728.  
  729. (define %inherit-from-mixins
  730.   (letrec
  731.     ((insert-entry
  732.       (lambda (entry class1 method-entry name2 previous current)
  733.         (cond ((null? current)
  734.                (set-cdr! previous
  735.                          (cons (cons (caadr method-entry) name2) '())))
  736.               ((%before name2 (cdar current) (%sc-name class1))
  737.                (set-cdr! previous
  738.                          (cons (cons (caadr method-entry) name2) current)))
  739.               (else '()))))
  740.  
  741.     (insert
  742.       (lambda (struct1 entry class1 struct2 name2)
  743.         (define loop-insert
  744.            (lambda (struct1 entry class1 struct2 name2 previous current)
  745.              (if (insert-entry entry class1 struct2 name2 previous current)
  746.                  struct1
  747.                  (loop-insert struct1 entry class1 struct2 name2
  748.                               current (cdr current)))))
  749.          (loop-insert struct1 entry class1 struct2 name2 entry (cdr entry))))
  750.  
  751.     (add-entry
  752.       (lambda (struct1 class1 method-entry name2)
  753.         (cons (list (car method-entry) (cons (caadr method-entry) name2))
  754.               struct1)))
  755.  
  756.     (combine-methods
  757.       (lambda (struct1 class1 struct2 name2)
  758.     (if struct2
  759.         (combine-methods
  760.          (let ((entry (assq (caar struct2) struct1)))
  761.            (if entry
  762.            (insert struct1 entry class1 (car struct2) name2)
  763.            (add-entry struct1 class1 (car struct2) name2)))
  764.          class1
  765.          (cdr struct2)
  766.          name2)
  767.         struct1)))
  768.  
  769.      (combine-vars
  770.        (lambda (list1 list2)
  771.      (if list2
  772.          (combine-vars
  773.           (if (assq (caar list2) list1)
  774.           list1
  775.           (cons (car list2) list1))
  776.           (cdr list2))
  777.          list1)))
  778.      )
  779.  
  780.   (lambda (cvs ivs methods mixins class receiver)
  781.     (define loop-mixins
  782.        (lambda (cvs ivs methods mixins class receiver)
  783.          (if mixins
  784.              (let ((mixin-class (%sc-name->class (car mixins))))
  785.                (%inherit-method-vars mixin-class)
  786.                (loop-mixins
  787.                  (combine-vars cvs (%sc-allcvs mixin-class))
  788.                  (combine-vars ivs (%sc-allivs mixin-class))
  789.                  (combine-methods methods class
  790.                           (%sc-method-structure mixin-class) (car mixins))
  791.                  (cdr mixins)
  792.                  class
  793.                  receiver))
  794.              (receiver class cvs ivs methods ))))
  795.      (loop-mixins cvs ivs methods mixins class receiver))))
  796.  
  797. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  798. ;;;                                                                 ;;;
  799. ;;;                     S c o o p s                                 ;;;
  800. ;;;                                                                 ;;;
  801. ;;;                                                                 ;;;
  802. ;;;        Rewritten 5/20/87 for cscheme                            ;;;
  803. ;;;        by Steve Sherin--U of P                                  ;;;
  804. ;;;                   File : interf.scm                             ;;;
  805. ;;;                                                                 ;;;
  806. ;;;                 Amitabh Srivastava                              ;;;
  807. ;;;                                                                 ;;;
  808. ;;;    This file contains class definition and processing of        ;;;
  809. ;;;    define-class.                                                ;;;
  810. ;;;                                                                 ;;;
  811. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  812.  
  813. (define (oddmemq obj list)
  814.   (cond ((not (pair? list)) #f)
  815.         ((not (pair? (cdr list))) #f)
  816.         ((eq? obj (car list)) list)
  817.         (else (oddmemq obj (cddr list)) )))
  818.  
  819. ;;; DEFINE-CLASS
  820. (syntax-table-define user-initial-syntax-table 'define-class
  821.   (macro e
  822.     (let ((name (car e)) 
  823.       (classvars '()) 
  824.       (instvars '()) (mixins '())
  825.           (options '())
  826.       (allvars '())
  827.       (method-values '())(inits '()))
  828.       (letrec
  829.       ((chk-class-def
  830.         (lambda (deflist)
  831.           (if deflist
  832.           (begin
  833.             (cond ((eq? (caar deflist) 'classvars)
  834.                (set! classvars (cdar deflist)))
  835.               ((eq? (caar deflist) 'instvars)
  836.                (set! instvars (cdar deflist)))
  837.               ((eq? (caar deflist) 'mixins)
  838.                (set! mixins (cdar deflist)))
  839.               ((eq? (caar deflist) 'options)
  840.                (set! options (cdar deflist)))
  841.               (else (error-handler (caar deflist) 0 '())))
  842.             (chk-class-def (cdr deflist)))
  843.           (update-allvars))))
  844.  
  845.        (update-allvars
  846.         (lambda ()
  847.           (set! allvars
  848.             (append (map (lambda (a) (if (symbol? a) a (car a)))
  849.                     classvars)
  850.                 (map (lambda (a) (if (symbol? a) a (car a)))
  851.                     instvars)))))
  852.  
  853.  
  854.        (chk-option
  855.         (lambda (opt-list)
  856.           (let loop ((opl opt-list)(meths '()))
  857.         (if opl
  858.             (loop
  859.              (cdr opl)
  860.              (cond ((eq? (caar opl) 'gettable-variables)
  861.                 (append (generate-get (cdar opl)) meths))
  862.                ((eq? (caar opl) 'settable-variables)
  863.                 (append (generate-set (cdar opl)) meths))
  864.                ((eq? (caar opl) 'inittable-variables)
  865.                 (set! inits (cdar opl)) meths)
  866.                (else (error-handler (car opl) 1 '()))))
  867.             meths))))
  868.  
  869.        (chk-cvs
  870.         (lambda (list-var)
  871.           (map
  872.            (lambda (a)
  873.          (if (symbol? a)
  874.              (list a #f)
  875.              a))
  876.            list-var)))
  877.  
  878.        (chk-init
  879.         (lambda (v-form)
  880.           (if (memq (car v-form) inits)
  881.           `(,(car v-form)
  882.             (let ((temp (oddmemq ',(car v-form) %sc-init-vals)))
  883.                     ;was '%sc-init-vals
  884.               (if temp (cadr temp)
  885.               ,(cadr v-form))))
  886.           v-form)))
  887.  
  888.        (chk-ivs
  889.         (lambda (list-var)
  890.           (map
  891.            (lambda (var)
  892.          (chk-init
  893.           (cond ((symbol? var) (list var #f))
  894.                         ((not-active? (cadr var)) var)
  895.                         (else (active-val (car var) (cadr var))))))
  896.            list-var)))
  897.  
  898.        (not-active?
  899.         (lambda (a)
  900.           (or (not (pair? a))
  901.           (not (eq? (car a) 'active)))))
  902.  
  903.        (empty-slot?
  904.         (lambda (form)
  905.           (cond
  906.            ((symbol? form) #f)
  907.            ((eq? form #f) #t)
  908.            (else #f))))
  909.  
  910.        (active-val
  911.         (lambda (var active-form)
  912.           (let loop ((var var)(active-form active-form)
  913.                   (getfns '())(setfns '%sc-val))
  914.         (if (not-active? (cadr active-form))
  915.             (create-active
  916.              var
  917.              (if (empty-slot? (caddr active-form))
  918.              getfns
  919.              (cons (caddr active-form) getfns))
  920.              (list 'set! var
  921.                (if (empty-slot? (cadddr active-form))
  922.                    setfns
  923.                    (list (cadddr active-form) setfns)))
  924.              (cadr active-form))
  925.             (loop
  926.              var
  927.              (cadr active-form)
  928.              (if (empty-slot? (caddr active-form))
  929.              getfns
  930.              (cons (caddr active-form) getfns))
  931.              (if (empty-slot? (cadddr active-form))
  932.              setfns
  933.              (list (cadddr active-form) setfns)))))))
  934.  
  935.        (create-active
  936.         (lambda (var getfns setfns localstate)
  937.           (begin
  938.         (set! method-values
  939.               (cons `(CONS ',(concat "GET-" var)
  940.                    (list 'lambda '() ',(expand-getfns var getfns)))
  941.                 (cons `(CONS ',(concat "SET-" var)
  942.                      (list 'lambda (list '%sc-val)
  943.                            ',setfns))
  944.                   method-values)))
  945.         (list var localstate))))
  946.  
  947.        (expand-getfns
  948.         (lambda (var getfns)
  949.           (let loop ((var var)(gets getfns)(exp-form var))
  950.         (if gets
  951.             (loop
  952.              var
  953.              (cdr gets)
  954.              (list (car gets) exp-form))
  955.             exp-form))))
  956.        (concat
  957.         (lambda (str sym)
  958.           (intern (string-append str (symbol->string sym)))))
  959.  
  960.        (generate-get
  961.         (lambda (getlist)
  962.           (map
  963.            (lambda (a)
  964.          `(CONS ',(concat "GET-" a)
  965.             (list 'lambda '()
  966.                   ',a)))
  967.            getlist)))
  968.  
  969.        (generate-set
  970.         (lambda (setlist)
  971.           (map
  972.            (lambda (a)
  973.          `(CONS ',(concat "SET-" a)
  974.             (list 'lambda (list '%sc-val)
  975.                   (list 'set! ',a '%sc-val))))
  976.            setlist)))
  977.  
  978.        )
  979.  
  980. ;; define-class begins here.
  981.  
  982.     (begin
  983.       (chk-class-def (cdr e))
  984.       (set! method-values
  985.         (chk-option
  986.          (map (lambda (a) (if (symbol? a) (cons a allvars) a))
  987.              options)))
  988.       (set! instvars (and instvars (chk-ivs instvars)))
  989. ;; Evaluate here so that active-value functions are generated properly.
  990. ;; --Steve Sherin
  991.       (set! classvars (and classvars (chk-cvs classvars)))
  992.       (eval
  993.        `(DEFINE ,name
  994.           (%SC-MAKE-CLASS
  995.            ',name
  996.            ',classvars
  997.            ',instvars
  998.            ',mixins
  999.            ,(and method-values (cons 'list method-values))
  1000.            ))
  1001.        user-initial-environment)
  1002.       )))))
  1003. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1004. ;;;                                                                 ;;;
  1005. ;;;                     S c o o p s                                 ;;;
  1006. ;;;                                                                 ;;;
  1007. ;;;                                                                 ;;;
  1008. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  1009. ;;;        by Steve Sherin--U of P                    ;;;
  1010. ;;;                   File : send.scm                               ;;;
  1011. ;;;                                                                 ;;;
  1012. ;;;                 Amitabh Srivastava                              ;;;
  1013. ;;;                                                                 ;;;
  1014. ;;;-----------------------------------------------------------------;;;
  1015. ;;;    One does not have to use the SEND form to invoke methods     ;;;
  1016. ;;;    in the same class; they can be invoked as Scheme functions.  ;;;
  1017. ;;;                                                                 ;;;
  1018. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1019.  
  1020. ;;; SEND
  1021. (define-macro-both (send . e)
  1022.     (let ((args (cddr e))
  1023.       (msg (cadr e))
  1024.       (obj (car e)))
  1025.       `(let* ((set-parent! (access ic-environment/set-parent!
  1026.                    environment-package))
  1027.           (ep environment-parent)
  1028.           (ibot ,obj)
  1029.           (itop (ep (ep ibot)))
  1030.           (ipar (ep itop))
  1031.           (class (access %sc-class ibot))
  1032.           (ctop (%sc-class-env class))
  1033.           (cpar (ep ctop))
  1034.           (cbot (%sc-method-env class))
  1035.           (instance-safe? (eq? ipar cbot)))
  1036.  
  1037.      (without-interrupts
  1038.       (lambda ()
  1039.         (dynamic-wind
  1040.          (lambda ()
  1041.            (set-parent! ctop ibot)
  1042.            (if instance-safe?
  1043.            (set-parent! itop cpar)))
  1044.  
  1045.  
  1046.          (lambda ()
  1047.            ;; I think that the next line should really be
  1048.            ;; ((environment-lookup cbot ',msg) ,@args))
  1049.            ;; -markf
  1050.            (in-package cbot (,msg ,@args)))
  1051.  
  1052.          (lambda ()
  1053.            (set-parent! ctop cpar)
  1054.            (set-parent! itop cbot))
  1055.          ))))))
  1056.  
  1057.  
  1058. ;;; SEND-IF-HANDLES
  1059. (syntax-table-define user-initial-syntax-table 'send-if-handles
  1060.   (macro e
  1061.     (let ((obj (car e))
  1062.       (msg (cadr e))
  1063.       (args (cddr e)))
  1064.       `(let
  1065.        ((self ,obj))
  1066.  
  1067.      (if (assq ',msg (%sc-method-structure (access %sc-class self)))
  1068.          (send self ,msg ,@args)
  1069.          #f)))))
  1070.  
  1071.  
  1072.  
  1073. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1074. ;;;                                                                 ;;;
  1075. ;;;                     S c o o p s                                 ;;;
  1076. ;;;                                                                 ;;;
  1077. ;;;                                                                 ;;;
  1078. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  1079. ;;;        by Steve Sherin--U of P                    ;;;
  1080. ;;;                   File : utl.scm                                ;;;
  1081. ;;;                                                                 ;;;
  1082. ;;;                 Amitabh Srivastava                              ;;;
  1083. ;;;                                                                 ;;;
  1084. ;;;    This file contains misc. routines                            ;;;
  1085. ;;;                                                                 ;;;
  1086. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1087.  
  1088.  
  1089. ;;;   Error handler. Looks up the error message in the table and
  1090. ;;;   prints it.
  1091.  
  1092. (define error-handler
  1093.   (let ((error-table
  1094.      (let ((table (make-vector 8)))
  1095.        (vector-set! table 0 " Invalid class definition ")
  1096.        (vector-set! table 1 " Invalid option ")
  1097.        (vector-set! table 2 " Class not defined ")
  1098.        (vector-set! table 3 " Method has been deleted ")
  1099.        (vector-set! table 4 " Method is not present ")
  1100.        (vector-set! table 5 " Variable is not present")
  1101.        (vector-set! table 6 " Not a Scoops Class")
  1102.        (vector-set! table 7 " Class not compiled ")
  1103.        table)))
  1104.     (lambda (msg number flag)
  1105.       (if flag
  1106.           (error (vector-ref error-table number) msg)
  1107.           (bkpt (vector-ref error-table number) msg)))))
  1108.  
  1109.  
  1110. ;;;   some functions defined globally which will be moved locally later
  1111.  
  1112.         (define %sc-class-description
  1113.            (lambda (class)
  1114.               (writeln " ")
  1115.               (writeln "    CLASS DESCRIPTION    ")
  1116.               (writeln "    ==================    ")
  1117.               (writeln " ")
  1118.               (writeln " NAME            : " (%sc-name class))
  1119.               (writeln " CLASS VARS      : "
  1120.                        (map car (%sc-allcvs class)))
  1121.               (writeln " INSTANCE VARS   : "
  1122.                        (map car (%sc-allivs class)))
  1123.               (writeln " METHODS         : "
  1124.                        (map car (%sc-method-structure class)))
  1125.               (writeln " MIXINS          : " (%sc-mixins class))
  1126.               (writeln " CLASS COMPILED  : " (%sc-class-compiled class))
  1127.               (writeln " CLASS INHERITED : " (%sc-class-inherited class))
  1128.            ))
  1129. ;;;
  1130.  
  1131.     (define %sc-inst-desc
  1132.        (lambda (inst)
  1133.          (letrec ((class (access %sc-class inst))
  1134.                   (printvars
  1135.                     (lambda (f1 f2)
  1136.               (if f1            ; another var
  1137.               (begin
  1138.                (writeln "   " (caar f1) " : "
  1139.                 (cadr (assq (caar f1) f2)))
  1140. ;; environment bindings in list form vs. pair form.  Steve Sherin
  1141.                (printvars (cdr f1) f2))
  1142.                 *the-non-printing-object*))))
  1143.             (writeln " ")
  1144.         (writeln "  INSTANCE DESCRIPTION      ")
  1145.         (writeln "  ====================      ")
  1146.         (writeln " ")
  1147.          (writeln "  Instance of Class :  " (%sc-name class))
  1148.         (writeln " ")
  1149.         (writeln "  Class Variables : ")
  1150.             (printvars (%sc-allcvs class)
  1151.                (environment-bindings (%sc-class-env class)))
  1152.             (writeln " ")
  1153.         (writeln "  Instance Variables :")
  1154.             (printvars (%sc-allivs class) (environment-bindings inst))
  1155.            )))
  1156.  
  1157. ;;;
  1158. (define %scoops-chk-class-compiled
  1159.   (lambda (name class)
  1160.     (or (%sc-class-compiled class)
  1161.         (error-handler name 7 #t))))
  1162.  
  1163. ;;;
  1164. (define %sc-class-info
  1165.   (lambda (fn)
  1166.     (lambda (class)
  1167.       (%scoops-chk-class class)
  1168.       (map car (fn class)))))
  1169.  
  1170. ;;; ALL-CLASSVARS
  1171. (set! all-classvars (%sc-class-info %sc-allcvs))
  1172.  
  1173. ;;; ALL-INSTVARS
  1174. (set! all-instvars (%sc-class-info %sc-allivs))
  1175.  
  1176. ;;; ALL-METHODS
  1177. (set! all-methods (%sc-class-info %sc-method-structure))
  1178.  
  1179. ;;; (CLASS-COMPILED? CLASS)
  1180. (set! class-compiled?
  1181.   (lambda (class)
  1182.     (%scoops-chk-class class)
  1183.     (%sc-class-compiled class)))
  1184.  
  1185. ;;; (CLASS-OF-OBJECT OBJECT)
  1186. (syntax-table-define user-initial-syntax-table 'class-of-object
  1187.   (macro e
  1188.     `(%sc-name (access %sc-class ,(car e)))))
  1189.  
  1190. ;;; CLASSVARS
  1191. (set! classvars (%sc-class-info %sc-cv))
  1192.  
  1193. ;;; DESCRIBE
  1194. (set! describe
  1195.   (lambda (class-inst)
  1196.     (if (vector? class-inst)
  1197.         (begin
  1198.           (%scoops-chk-class class-inst)
  1199.           (%sc-class-description class-inst))
  1200.         (%sc-inst-desc class-inst))))
  1201.  
  1202. ;;; (GETCV CLASS VAR)
  1203. (syntax-table-define user-initial-syntax-table 'getcv
  1204.   (macro e
  1205.     (let ((class (car e))
  1206.       (var (cadr e)))
  1207.       `(begin
  1208.          (and (%sc-name->class ',class)
  1209.               (%scoops-chk-class-compiled ',class ,class))
  1210.      ((access ,(%sc-concat "GET-" var) (%sc-method-env ,class)))))))
  1211.  
  1212. ;;; INSTVARS
  1213. (set! instvars (%sc-class-info %sc-iv))
  1214.  
  1215. ;;; METHODS
  1216. (set! methods (%sc-class-info %sc-method-values))
  1217.  
  1218. ;;; MIXINS
  1219. (set! mixins
  1220.   (lambda (class)
  1221.     (%scoops-chk-class class)
  1222.     (%sc-mixins class)))
  1223.  
  1224. ;;; (NAME->CLASS NAME)
  1225. (syntax-table-define user-initial-syntax-table 'name->class
  1226.   (macro e
  1227.     `(%sc-name->class ,(car e))))
  1228.  
  1229. ;;; (RENAME-CLASS (CLASS NEW-NAME))
  1230. (syntax-table-define user-initial-syntax-table 'rename-class
  1231.   (macro e
  1232.     (let ((class (caar e))
  1233.       (new-name (cadar e)))
  1234.       `(begin
  1235.      (%sc-name->class ',class)
  1236.      (%sc-set-name ,class ',new-name)
  1237.      (2d-put! ',new-name '%class ,class)
  1238.      (eval '(define ,new-name ,class) user-initial-environment)
  1239.      ',new-name))))
  1240.  
  1241. ;;; (SETCV CLASS VAR VAL)
  1242. (syntax-table-define user-initial-syntax-table 'setcv
  1243.   (macro e
  1244.     (let ((class (car e))
  1245.       (var (cadr e))
  1246.       (val (caddr e)))
  1247.       `(begin
  1248.          (and (%sc-name->class ',class)
  1249.               (%scoops-chk-class-compiled ',class ,class))
  1250.      ((access ,(%sc-concat "SET-" var) (%sc-method-env ,class)) ,val)))))
  1251.